home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / aegis_fault.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  223 lines
  1. (herald aegis_fault (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Fault frame hacking
  27.  
  28. ;;; Fault frame: (see also start_t.asm, & aem68kernel.t)
  29. ;;; out of foreign-code:
  30.  
  31. ;;;  fault-frame-header/number of slots
  32. ;;;  foreign-call-cont
  33.  
  34. ;; otherwise:
  35.  
  36. ;;;  fault-frame-header/number of slots
  37. ;;;  number of pointers on stack at fault
  38. ;;;  hack top of stack if PC is in kernel, else 0
  39. ;;;  PC     
  40. ;;;  P
  41. ;;;  A1     
  42. ;;;  A2     
  43. ;;;  A3     
  44. ;;;  AN     
  45. ;;;  TP
  46. ;;; extra scratch
  47. ;;; extra pointer
  48. ;;;   .
  49. ;;; pointer temps
  50. ;;; scratch-temps
  51. ;;;  .
  52. ;;; offset from this slot to diagnotic frame
  53. ;;; old SP
  54. ;;; fault SP (redundant for interrupt dispatcher ease)
  55. ;;; some number of bytes for alignment
  56. ;;; ...
  57. ;;; ... dc.w $DFDF          (apollo diagnostic frame begins here)   
  58. ;;; ... dc.l fault status
  59. ;;; ... D0
  60. ;;; ... ...
  61. ;;; ... A7
  62. ;;; ... ...
  63. ;;;  T stack begins here    
  64.  
  65. ;;; FF = fault frame        (a T concept)
  66. ;;; DF = diagnostic frame   (an Aegis concept)
  67.  
  68. (define-constant foreign-fault-frame? alt-bit-set?)
  69.                                       
  70. (define (fault-frame-slots frame)
  71.   (cond ((foreign-fault-frame? frame)
  72.          (bytev-length frame))
  73.         (else
  74.          (fx+ (bytev-length frame)                ; size
  75.               (if (eq? (extend-elt frame 1) 0)
  76.                   (extend-elt frame 0)            ; pointers on top
  77.                   1)))))                          ; hack
  78.  
  79. (define-handler fault-frame
  80.   (object nil
  81.       ((frame-previous self) 
  82.        (make-pointer self (fault-frame-slots self)))
  83.       ((crawl-exhibit self) (crawl-exhibit-fault-frame self))
  84.       ((print-type-string self) "Fault-frame")))
  85.                                                                   
  86. (define (print-register frame name index)
  87.   (let ((out (crawl-output)))
  88.     (format out " ~s = " name)
  89.     (print-one-line (extend-elt frame index) out)
  90.     (newline out)))
  91.  
  92. ;;; Fault handler
  93.  
  94.  
  95. (define-constant fault_$stop                   #x120018)
  96. (define-constant fault_$process_interrupt      #x12001f)
  97. (define-constant fault_$quit                   #x120010)
  98. (define-constant mst_$guard_fault              #x4000a)
  99. (define-constant fault_$guard                  mst_$guard_fault)
  100. (define-constant bat_$disk_full                #x10002)
  101. (define-constant time_$itimer_real             #xD0007)
  102. (define-constant fault_$hangup                 #xb000e)
  103.  
  104. ;;; We arrive here whenever we get a T-asynchronous fault.
  105. ;;; Be careful not to do any consing, because the disk might be full.
  106.  
  107. (define (re-enable-faults)
  108.     (pfm_$enable)
  109.     0)
  110.  
  111. (define-foreign pfm_$enable ("PFM_$ENABLE") ignore)
  112.  
  113. ;;; FAULT-ENTRY is called from the lap code in aem68kernel.
  114. ;++ known bug fix later
  115. ;++ pfm_cleanup 
  116. ;++ pfm_signal
  117. ;++ valid frame
  118.  
  119. (define (fault-entry status frame)
  120.   (re-enable-faults)
  121.   (select status
  122.     ((fault_$stop fault_$hangup) (exit))
  123.     ((fault_$guard)  
  124.      (check-continue frame (lambda () (non-continuable-error "Stack overflow"))))
  125.     ((fault_$process_interrupt) 
  126.      (check-continue frame (lambda () (z-breakpoint "Z system interrupt"))))
  127.     ((fault_$quit) 
  128.      (check-continue frame (lambda () (breakpoint "Interrupt"))))
  129.     ((time_$itimer_real) 
  130.      (check-continue frame timer-interrupt))
  131.     (else
  132.      (non-continuable-error "~a (status ~x)" 
  133.                             (local-os-error-message status) 
  134.                             status))))
  135.  
  136. (define (check-continue frame thunk) 
  137.   (if (not (foreign-fault-frame? frame))
  138.       (thunk)
  139.       (let ((stamp (gc-stamp)))
  140.         (thunk)
  141.         (if (fxn= (gc-stamp) stamp)
  142.             (non-continuable-error "Interrupted code can't continue due to GC")))))
  143.  
  144. ;;; Initialize the condition system.  This procedure must be called
  145. ;;; to enable the T error system.  It should be called as soon as
  146. ;;; possible during the startup sequence.
  147.  
  148. (define (initialize-condition-system) 
  149.     (pfm_$establish_fault_handler 0
  150.                                   4
  151.                                   (vref (system-global slink/boot-args)
  152.                     3)   ; boot/interrupt-xenoid
  153.                                   nil))
  154. (define-foreign pfm_$establish_fault_handler
  155.     ("PFM_$ESTABLISH_FAULT_HANDLER" (in rep/integer) 
  156.                                   (in rep/integer-16-u) 
  157.                                   (in rep/extend)
  158.                                   (out rep/integer))
  159.         rep/integer)
  160.  
  161.  
  162. ;;; Exit from T, optionally setting the return code.
  163.  
  164. (define-foreign pgm_$exit ("PGM_$EXIT") ignore)
  165.  
  166. (define-foreign pgm_$set_severity
  167.   ("PGM_$SET_SEVERITY" (in rep/integer-16-u)) ignore)
  168.  
  169. (lset exit-agenda (make-agenda 'exit-agenda))
  170.  
  171. (define (exit . arg)
  172.   (let ((severity (if (null? (car arg)) 0 (car arg))))
  173.     (exit-agenda)
  174.     (unwind-to-state nil)
  175.     (pgm_$set_severity severity)
  176.     (exit-and-dheap)))
  177.  
  178.  
  179. ;;; Local OS error handling
  180. ;++ apollo error text implementation
  181. ;++ nothing has been hacked for faults during GC (see t2)
  182.  
  183.  
  184. (define-foreign error_$get_text
  185.     ("ERROR_$GET_TEXT" (in     rep/integer)
  186.                      (ignore rep/extend)
  187.                      (out    rep/integer-16-u)
  188.                      (ignore rep/extend)
  189.                      (out    rep/integer-16-u)
  190.                      (ignore rep/extend)
  191.                      (out    rep/integer-16-u) )
  192.     ignore)
  193.  
  194. ;;; OS interface error checking utilities
  195.  
  196. (define-constant (CHECK-STATUS STATUS)
  197.   (if (fxN= status 0) (local-os-error status)))
  198.  
  199. (define (local-os-error STATUS)
  200.   (error "~&** VM Aegis error - ~a" (local-os-error-message status)))
  201.  
  202. (define (local-os-error-message status)
  203.   (let ((subsys (make-string 80))
  204.         (module (make-string 80))
  205.         (code   (make-string 80)))
  206.     (receive (sl ml cl)
  207.              (error_$get_text status (string-text subsys) 0
  208.                                      (string-text module) 0
  209.                                      (string-text code)   0)
  210.       (cond (*z?*
  211.              (set (string-length code) cl)
  212.              code)
  213.             (else
  214.              (set (string-length subsys) sl)
  215.              (set (string-length module) ml)
  216.              (set (string-length code)   cl)
  217.              (format nil "~a [~a/~a]" code subsys module))))))
  218.                               
  219.  
  220.  
  221.  
  222.  
  223.